perm filename RVRS.F4[MSS,LCS] blob
sn#260745 filedate 1977-01-28 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE RVRS(IT)
C00007 ENDMK
Cā;
SUBROUTINE RVRS(IT)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
K=1
1 R=CODEN(KPN,K,Q,J)
IF(R.NE.1)GO TO 2
C JUMP IF NOT A NOTE
IF(Q(J+5).LT.10)GO TO 10
C JUMP IF NO STEM ON IT
KK=K+1
3 IF(KK.GT.IT)RETURN
RR=CODEN(KPN,KK,Q,JJ)
IF(RR.NE.1)GO TO 5
C JUMP IF NOT A NOTE
IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7 KK=KK+1
GO TO 3
C DID NOT FIND BEAM NEARBY
6 RZ=AMOD(Q(J+4),100.0)
N=J+5
A=10
IF(RZ.GE.7)GO TO 60
IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
A=-A
GO TO 15
60 IF(Q(N).GE.20)GO TO 10
C THERE MUST BE A BETTER WAY!
15 Q(N)=Q(N)+A
GO TO 10
CCCCC8 IF(Q(N).LT.20)GO TO 10
CCCCC A=-A
C STEM UP
CCCCC GO TO 15
5 IF(RR.NE.6)GO TO 6
20 B=Q(JJ+4)
C=Q(JJ+5)
D=(B+C)/2.
IF(RR.EQ.5)GO TO 9
IF(RR.NE.6)GO TO 10
B=Q(JJ+6)+1.
C SAVES RANGE OF BEAM +1.
IF(Q(JJ+7).GE.20)GO TO 11
C NOW STEMS ARE UP
IF(D.LT.7)GO TO 12
C JUMP TO 12 IF ALL OK
CC C=-10
JSTM=0
C SAVE FOR REVERSED STEMS
GO TO 23
11 IF(D.GE.7.)GO TO 12
C STEMS DOWN
C JUMP IF NO REVERSE NEEDED
JSTM=-1
23 JH=0
CHNG=0
DO 16 N=K,IT
R=CODEN(KPN,N,Q,KK)
IF(Q(KK+3).GT.B)GO TO 140
IF(R.NE.1)GO TO 17
L=5+KK
IF(Q(L).LT.10)GO TO 16
C PASS NOTES WITH NO STEM
R=Q(KK+8)
C THE STEM LENGTH
IF(R.EQ.999)R=0
Q(KK+8)=-R
C FOR THE INVERSION
19 C=10.
A=Q(L)
IF(A.GE.20)C=-C
Q(L)=C+A
IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
JH=4
160 R=Q(JJ+JH)-Q(KK+4)
C=-1
IF(JSTM)GO TO 163
C=R
R=1
C NOW STEMS UP
163 IF(R.GT.C)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
CHNG=C-R
IF(JSTM.EQ.0)CHNG=-CHNG
JH=JJ+4
Q(JH)=Q(JH)+CHNG
JH=JH+1
Q(JH)=Q(JH)+CHNG
162 IF(L)GO TO 141
C FOR ESCAPE FROM LOOP
161 JH=KK
C JH SAVES PTR TO LAST NOTE UNDER BEAM
GO TO 16
17 IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
L=7+KK
GO TO 19
18 IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
C=-3.8
IF(Q(KK+7))C=-C
CALL SLRV(KK,C)
C TO REVERSE SLUR
CC Q(KK+7)=-Q(KK+7)
16 CONTINUE
C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140 KK=JH
L=-1
JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
GO TO 160
141 IF(CHNG.EQ.0)GO TO 14
IF(CHNG)CHNG=-CHNG
DO 142 N=K,IT
C TO READJUST STEMS UNDER REVERSED BEAMS
KK=KPN(N)
IF(Q(KK+3).GT.B)GO TO 14
IF(Q(KK+1).NE.1)GO TO 142
Q(KK+8)=Q(KK+8)+CHNG
C THE STEM LENGTH
142 CONTINUE
GO TO 14
C NEXT FOR SLURS
9 B=-3.8
IF(Q(JJ+7))GO TO 24
IF(D.GT.7)GO TO 10
C JUMP TO LEAVE STEM UP
GO TO 25
24 IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
B=-B
CC25 Q(JJ+4)=Q(JJ+4)+B
CC Q(JJ+5)=Q(JJ+5)+B
CC Q(JJ+7)=-R
25 CALL SLRV(JJ,B)
GO TO 10
12 DO 13 N=K+1,IT
KK=KPN(N)
13 IF(Q(KK+3).GT.B)GO TO 14
C JUMP OUT WHEN PAST END OF BEAM.
14 K=N-1
GO TO 10
2 IF(R.NE.6)GO TO 21
22 JJ=J
RR=R
GO TO 20
21 IF(R.EQ.5)GO TO 22
10 IF(K.GT.IT)RETURN
K=K+1
GO TO 1
END